{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE RankNTypes                 #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Majalan.Base.Chain
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Stepped traversal through an ImpulseMap.
-- 
--------------------------------------------------------------------------------

module Majalan.Base.Chain

  where


import Majalan.Base.Advance
import Majalan.Base.BeatPattern
import Majalan.Base.Context
import Majalan.Base.Event
import Majalan.Base.EventList
import Majalan.Base.Internal.Beat

import Control.Applicative
import Control.Monad
import Data.Monoid

-- CURRENTLY BROKEN - will not be fixed (wrong abstraction)


-- Design Note
-- Musically there is probably too little information in an 
-- impulse stream to do anything useful. Knowing bar delims 
-- seems more profitable.
-- 

type AInput impl = [Bar impl]

type AFk uctx impl ans   = AInput impl -> Advance uctx ans
type ASk uctx impl ans a = a -> AFk uctx impl ans -> AInput impl -> Advance uctx ans


-- | 2-continuation parser
newtype BarParser uctx impl a = BarParser { 
    getBarParser :: forall ans. 
                    ASk uctx impl ans a -> AFk uctx impl ans -> AInput impl -> Advance uctx ans }

type instance UserCtx (BarParser uctx impl) = uctx


instance Functor (BarParser uctx impl) where
  fmap f ma = BarParser $ \sk fk inp -> 
                getBarParser ma (sk . f) fk inp


instance Applicative (BarParser uctx impl) where
  pure a    = BarParser $ \sk fk inp -> sk a fk inp
  mf <*> ma = BarParser $ \sk -> 
                getBarParser mf $ \f -> getBarParser ma $ \a -> sk (f a)


instance Monad (BarParser uctx impl) where
  return    = pure
  ma >>= k  = BarParser $ \sk -> 
                getBarParser ma $ \a -> getBarParser (k a) sk

instance Alternative (BarParser uctx impl) where
  empty   = BarParser $ \_ fk inp -> fk inp
  p <|> q = BarParser $ \sk fk -> getBarParser p sk (getBarParser q sk fk)

instance MonadPlus (BarParser uctx impl) where
  mzero = empty
  mplus = (<|>)

instance Monoid a => Monoid (BarParser uctx impl a) where
  mempty          = BarParser $ \sk -> sk mempty
  ma `mappend` mb = BarParser $ \sk -> 
                      getBarParser ma $ \a -> getBarParser mb $ \b -> sk (a <> b)


instance ContextM (BarParser uctx impl) where
  askCtx        = BarParser $ \sk fk inp -> askCtx >>= \a -> sk a fk inp
  localize f ma = BarParser $ \sk fk inp -> localize f $ getBarParser ma sk fk inp


runBarParser :: BarParser uctx impl a -> AInput impl -> EventList uctx (Maybe a)
runBarParser p inp = evalAdvance 0 $ getBarParser p sc fc inp
  where
    sc = \ans _ _ -> return $ Just ans
    fc = \_ -> return $ Nothing


metricSequence :: BarParser uctx impl z -> BeatPattern impl -> EventList uctx ()
metricSequence ma mpat = ask_meter_info >>= \(MeterInfo ts bpm) ->
    let bars = beatPatternBars ts bpm mpat
    in runBarParser ma bars >> return ()


type BInput impl = [SecDivision impl]


type BFk uctx impl ans   = BInput impl -> Advance uctx ans
type BSk uctx impl ans a = a -> BFk uctx impl ans -> BInput impl -> Advance uctx ans


-- | 2-continuation parser 
newtype BeatParser uctx impl a = BeatParser { 
    getBeatParser :: forall ans. 
                     BSk uctx impl ans a -> BFk uctx impl ans -> BInput impl -> Advance uctx ans }

type instance UserCtx (BeatParser uctx impl) = uctx


instance Functor (BeatParser uctx impl) where
  fmap f ma = BeatParser $ \sk fk inp -> 
                getBeatParser ma (sk . f) fk inp


instance Applicative (BeatParser uctx impl) where
  pure a    = BeatParser $ \sk fk inp -> sk a fk inp
  mf <*> ma = BeatParser $ \sk -> 
                getBeatParser mf $ \f -> getBeatParser ma $ \a -> sk (f a)


instance Monad (BeatParser uctx impl) where
  return    = pure
  ma >>= k  = BeatParser $ \sk -> 
                getBeatParser ma $ \a -> getBeatParser (k a) sk

instance Alternative (BeatParser uctx impl) where
  empty   = BeatParser $ \_  fk inp -> fk inp
  p <|> q = BeatParser $ \sk fk -> getBeatParser p sk (getBeatParser q sk fk)

instance MonadPlus (BeatParser uctx impl) where
  mzero = empty
  mplus = (<|>)

instance Monoid a => Monoid (BeatParser uctx impl a) where
  mempty          = BeatParser $ \sk -> sk mempty
  ma `mappend` mb = BeatParser $ \sk -> 
                      getBeatParser ma $ \a -> getBeatParser mb $ \b -> sk (a <> b)



instance ContextM (BeatParser uctx impl) where
  askCtx        = BeatParser $ \sk fk inp -> askCtx >>= \a -> sk a fk inp
  localize f ma = BeatParser $ \sk fk inp -> localize f $ getBeatParser ma sk fk inp




runBeatParser :: BeatParser uctx impl a -> BInput impl -> Advance uctx (Maybe a)
runBeatParser p inp = getBeatParser p sc fc inp
  where
    sc = \ans _ _ -> return $ Just ans
    fc = \_ -> return $ Nothing

-- | Automatic flushing ....
bar :: BeatParser uctx impl a -> BarParser uctx impl a
bar p = BarParser $ \sk fk inp -> case inp of 
    (b:bs) -> runBeatParser (p <* flush) (getBar b) >>= \ans -> case ans of
                Just a -> sk a fk bs
                Nothing -> fk inp
    [] -> fk inp


--------------------------------------------------------------------------------
-- Helpers

-- | Applicative cons.
--
-- Utility - not exported.
--
(<:>) :: Applicative f => f a -> f [a] -> f [a]
(<:>) p1 p2 = (:) <$> p1 <*> p2

-- | Applicative T - reverse fmap. 
--
-- Utility - not exported.
--
(<#>) :: Functor f => f a -> (a -> b) -> f b
(<#>) = flip fmap

--------------------------------------------------------------------------------

-- Vocab - don\'t steal the good names - potentially this module 
-- will be import qualified like Parsec\'s Token.


-- | Note - unlike Parsec we are concerned with writing as we 
-- go rather than just parsing. So which version is better:
--
-- > satisfyBeat :: (impl -> Bool) -> BeatParser uctx impl impl
--
-- Or:
--
-- > satisfyBeat :: (impl -> Bool) -> (impl -> Event uctx z) -> BeatParser uctx impl impl
--


type Assert uctx impl = BeatParser uctx impl impl

satisfyBeat :: (impl -> Bool) -> Assert uctx impl
satisfyBeat test = BeatParser $ \sk fk inp -> case inp of
    (B _ a : _) | test a -> sk a fk inp    -- NOTE - no consumption (right or wrong?)
    _                 -> fk inp


assertBeat :: Assert uctx impl -> (impl -> Event uctx a) -> BeatParser uctx impl a
assertBeat test p = test >> interpBeat p 

eob :: BeatParser uctx impl ()
eob = BeatParser $ \sk fk inp -> case inp of
    [] -> sk () fk []
    _ -> fk inp 

blank :: BeatParser uctx impl ()
blank = BeatParser $ \sk fk inp -> case inp of
    (B d _ : xs) -> advanceCursor d >> sk () fk xs
    (R d _ : xs) -> advanceCursor d >> sk () fk xs
    _ -> fk inp 



flush :: BeatParser uctx impl ()
flush = void $ manyTill blank eob

-- | peek doesn't consume (obviously), though it may fail.
--
peekBeat :: BeatParser uctx impl impl
peekBeat = BeatParser $ \sk fk inp -> case inp of
    (B _ a : xs) -> sk a fk xs
    _ -> fk inp 


-- | peek doesn't consume (obviously), though it may fail.
--
peekRest :: BeatParser uctx impl impl
peekRest = BeatParser $ \sk fk inp -> case inp of
    (R _ a : xs) -> sk a fk xs
    _ -> fk inp 

advanceRest :: BeatParser uctx impl () 
advanceRest = BeatParser $ \sk fk inp -> case inp of
    (R d _ : xs) -> advanceCursor d >> sk () fk xs
    _ -> fk inp 


interpRest :: (impl -> Event uctx a) -> BeatParser uctx impl a
interpRest mf = BeatParser $ \sk fk inp -> case inp of
    (R d i : xs) -> aevent d (mf i) >>= \a -> sk a fk xs
    _ -> fk inp 


interpBeat :: (impl -> Event uctx a) -> BeatParser uctx impl a
interpBeat mf = BeatParser $ \sk fk inp -> case inp of
    (B d i : xs) -> aevent d (mf i) >>= \a -> sk a fk xs
    _ -> fk inp 

whenBeat :: (impl -> Event uctx z) -> BeatParser uctx impl ()
whenBeat mf = (void $ interpBeat mf) <|> advanceRest


whiteSpace :: BeatParser uctx impl ()
whiteSpace = void $ many advanceRest


lexeme :: BeatParser uctx impl a -> BeatParser uctx impl a
lexeme ma = ma <* whiteSpace



oneOfBeat :: Eq impl => [impl] -> BeatParser uctx impl impl
oneOfBeat cs = satisfyBeat (`elem` cs)



beatsLeft :: BeatParser uctx impl Int
beatsLeft = BeatParser $ \sk fk inp -> sk (countB 0 inp) fk inp
  where
    countB i [] = i
    countB i (B {} : xs) = countB (i+1) xs
    countB i (R {} : xs) = countB i xs



--------------------------------------------------------------------------------
-- Bar parsers

allBeats :: (impl -> Event uctx a) -> BarParser uctx impl [a]
allBeats mf = bar $ whiteSpace *> many (lexeme $ interpBeat mf)




-- WARNING - need to test flush works rather then getting an 
-- unmusical truncation to the bar (shortening the meter pattern).
--
allBeatsList :: [p] -> (impl -> p -> Event uctx a) -> BarParser uctx impl [a]
allBeatsList ps mf = bar $ whiteSpace *> step ps
  where
    end         = [] <$ eob
    step []     = flush >> pure []
    step (q:qs) = let mf1 = lexeme $ interpBeat $ \impl -> mf impl q
                  in end <|> (mf1 <:> step qs)




allBeatsCyc :: [p] -> (impl -> p -> Event uctx a) -> BarParser uctx impl [a]
allBeatsCyc ps mf = bar $ whiteSpace *> step ps
  where
    end         = [] <$ eob
    step []     = end <|> step ps    -- refill cycle if not end-of-bar
    step (q:qs) = let mf1 = lexeme $ interpBeat $ \impl -> mf impl q
                  in end <|> (mf1 <:> step qs)





--------------------------------------------------------------------------------
-- General utility combinators



-- | 'many1' an alias for Control.Applicative 'some'. 
many1 :: Alternative f => f a -> f [a]
many1 = some

sepBy :: Alternative f => f a -> f z -> f [a]
sepBy p sep = sepBy1 p sep <|> pure []

sepBy1 :: Alternative f => f a -> f z -> f [a]
sepBy1 p sep = p <:> step 
  where
    step = (sep *> p) <:> step <|> pure []

sepEndBy :: Alternative f => f a -> f b -> f [a]
sepEndBy p sep = sepEndBy1 p sep <|> pure []

sepEndBy1 :: Alternative f => f a -> f b -> f [a]
sepEndBy1 p sep = (p <* sep) <:> step where
    step = (p <* sep) <:> step <|> pure []
    
manyTill :: Alternative f => f a -> f b -> f [a]
manyTill p end = step <|> pure [] where
    step = p <:> ((end <#> pure[]) <|> step)

manyTill1 :: Alternative f => f a -> f b -> f [a]
manyTill1 p end = p <:> step where
    step = (end <#> pure []) <|> (p <:> step)

-- | @satisfies@ needs /bind/ so its monadic and not applicative.
satisfies :: MonadPlus m => m a -> (a -> Bool) -> m a
satisfies p f = p >>= (\x -> if f x then return x else mzero)


count :: Applicative f => Int -> f a -> f [a]
count i p = if i > 0 then p <:> count (i-1) p else pure []

count_ :: Applicative f => Int -> f a -> f ()
count_ i p = if i > 0 then p *> count_ (i-1) p else pure ()
